home *** CD-ROM | disk | FTP | other *** search
/ The Business Master (3rd Edition) / The Business Master (3rd Edition).iso / files / grapties / sd204 / iostuff.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-11-22  |  15.0 KB  |  468 lines
  1. UNIT IOSTUFF;
  2. INTERFACE
  3. USES CRT,DOS;
  4.   TYPE
  5.   AnyStr   = String[80];
  6.   ShortStr = String[20];
  7.   LongStr  = String[160];
  8.   Map      = Record
  9.              ScrCh : Char;
  10.              ScrAt : Byte;
  11.              End;
  12.   Screen = Array[1..25,1..80] of Map;
  13.   AdapterTypes = (CGA,MDA,EGAColor,EGAMono);
  14.   VAR
  15.   Video : ^Screen;
  16.   ScreenHold : Array[0..3] of Screen;
  17.   AdapterType : AdapterTypes;
  18.   PROCEDURE MoveToScreen(Var Source,Dest; Len: Integer);
  19.   PROCEDURE MoveFromScreen(Var Source,Dest; Len: Integer);
  20.   PROCEDURE SaveScreen(NS:Integer);
  21.   PROCEDURE RestoreScreen(NS:Integer);
  22.   PROCEDURE SavePartScreen(X1,Y1,X2,Y2:Integer);
  23.   PROCEDURE RestorePartScreen(X1,Y1,X2,Y2:Integer);
  24.   PROCEDURE SetColor(F,B:integer);
  25.   PROCEDURE WriteSt(St:AnyStr;X,Y:Integer);
  26.   PROCEDURE WriteCh(Ch:Char;X,Y:Integer);
  27.   PROCEDURE WriteManyCh(Ch:Char;X,Y,Num:Integer);
  28.   PROCEDURE FillScr(Ch:Char);
  29.   FUNCTION  ReadFromScr(X,Y,Len:Integer):AnyStr;
  30.   FUNCTION  GetCh(X,Y:Integer):Char;
  31.   FUNCTION  GetAt(X,Y:Integer):Byte;
  32.   PROCEDURE Border(X1,Y1,X2,Y2: Integer; Header:AnyStr);
  33.   PROCEDURE SBorder(X1,Y1,X2,Y2: Integer; Header:AnyStr);
  34.   PROCEDURE Beep;
  35.   PROCEDURE Display(Msg : AnyStr;XD,YD:Integer);
  36.   PROCEDURE Wait;
  37.   FUNCTION  Yes(Prompt:AnyStr):Boolean;
  38.   PROCEDURE Linecursor;
  39.   PROCEDURE BigCursor;
  40.   PROCEDURE HideCursor;
  41.   PROCEDURE ShowCursor;
  42. IMPLEMENTATION
  43. VAR
  44.     PartHold   : Screen;
  45.     R          : Registers;
  46.     NS         : Integer;
  47.     SAttr      : Byte;
  48. {======================================================================}
  49. FUNCTION IsEGA : Boolean;
  50. BEGIN
  51.   R.AH := $12;       { Select Alternate Function Service }
  52.   R.BX := $10;       { Return EGA info }
  53.   Intr($10,R);       { Do it }
  54.   If R.BX = $10 then IsEGA := False    { If BX unchanged then EGA not there }
  55.                 else IsEGA := True;
  56. END;
  57.  
  58. {======================================================================}
  59. PROCEDURE CheckAdapter;
  60.  
  61. { Checks for the type of display adapter installed. }
  62. { Sets AdapterType to one of the following : }
  63. {    CGA      = Color Graphics Adapter }
  64. {    MDA      = Monochrome Display Adapter }
  65. {    EGAColor = EGA  With a Color Monitor }
  66. {    EGAMono  = EGA with a Monochrome Monitor }
  67.  
  68. VAR
  69.   AType : Byte;
  70.  
  71. BEGIN
  72.   If IsEGA then
  73.     Begin
  74.       R.AH := $12;
  75.       R.BL := $10;
  76.       Intr($10,R);
  77.       If (R.BH = 0) then AdapterType := EGAColor   { EGA Color adapter }
  78.                     else AdapterType := EGAMono; { EGA Mono adapter }
  79.     End
  80.   Else
  81.     Begin
  82.       Intr($11,R);
  83.       AType := (R.AL and $30) Shr 4;
  84.       Case AType of
  85.         1,2 : AdapterType := CGA;   { CGA }
  86.         3   : AdapterType := MDA;   { Mono }
  87.       Else AdapterType := CGA;      { CGA }
  88.       End; { Case }
  89.     End;
  90.  
  91.   If AdapterType = MDA then
  92.        Video := Ptr($B000,0000)
  93.   Else Video := Ptr($B800,0000);
  94.  
  95. END;
  96.  
  97.  
  98. {======================================================================}
  99. PROCEDURE MoveToScreen(Var Source,Dest; Len: Integer);
  100.  
  101. { Similar to Turbo Move but assumes the destination is in video  }
  102. { memory and thus writes only during retrace to avoid snow.      }
  103. { These are used only in Save and Restore Screen routines below. }
  104. { These routines are very fast and can be used as the basic      }
  105. { building blocks for other direct screen IO.  I have used Turbo }
  106. { Pascals regular Write routines whereever possible because they }
  107. { are sufficiently fast and much more understandable and stable. }
  108.  
  109. BEGIN
  110.     If AdapterType = CGA then Begin
  111.       Len:=Len Shr 1;
  112.       Inline($1E/$55/$BA/$DA/$03/$C5/$B6/ Source /$C4/$BE/ Dest /$8B/$8E/
  113.              Len /$FC/$AD/$89/$C5/$B4/$09/$EC/$D0/$D8/$72/$FB/$FA/$EC/
  114.              $20/$E0/$74/$FB/$89/$E8/$AB/$FB/$E2/$EA/$5D/$1F);
  115.     End
  116.     Else Move(Source,Dest,Len);
  117. END;
  118.  
  119. {======================================================================}
  120. PROCEDURE MoveFromScreen(Var Source,Dest; Len: Integer);
  121.  
  122. { Similar to Turbo Move but assumes the source is in video  }
  123. { memory and thus writes only during retrace to avoid snow. }
  124.  
  125. BEGIN
  126.     If AdapterType = CGA then Begin
  127.       Len:=Len Shr 1;
  128.       Inline($1E/$55/$BA/$DA/$03/$C5/$B6/ Source /$C4/$BE/ Dest /$8B/$8E/
  129.              Len /$FC/$EC/$D0/$D8/$72/$FB/$FA/$EC/$D0/$D8/$73/$FB/$AD/
  130.              $FB/$AB/$E2/$F0/$5D/$1F);
  131.     End
  132.   Else Move (Source,Dest,Len);
  133. END;
  134.  
  135. {======================================================================}
  136. PROCEDURE SaveScreen(NS:Integer);
  137. BEGIN
  138.   MoveFromScreen(Video^,ScreenHold[NS],4000);
  139. END;
  140.  
  141. {======================================================================}
  142. PROCEDURE RestoreScreen(NS:Integer);
  143. BEGIN
  144.   MoveToScreen(ScreenHold[NS],Video^,4000);
  145. END;
  146.  
  147. {======================================================================}
  148. PROCEDURE SavePartScreen(X1,Y1,X2,Y2:Integer);
  149. VAR
  150.   II,XLen : Integer;
  151. BEGIN
  152.   XLen := (X2-X1+1)*2;
  153.   For II := Y1 to Y2 do begin
  154.     MoveFromScreen(Video^[II,X1],ScreenHold[0,II,X1],XLen); { avoid snow }
  155.   End;
  156. END;
  157.  
  158. {======================================================================}
  159. PROCEDURE RestorePartScreen(X1,Y1,X2,Y2:Integer);
  160. VAR
  161.   II,XLen : Integer;
  162. BEGIN
  163.   XLen := (X2-X1+1)*2;
  164.   For II := Y1 to Y2 do begin
  165.     MoveToScreen(ScreenHold[0,II,X1],Video^[II,X1],XLen); { avoid snow }
  166.   End;
  167. END;
  168.  
  169. {======================================================================}
  170. PROCEDURE SetColor(F,B:integer);
  171.  
  172. { This sets variable TextAttr in Unit CRT to the colors F and B }
  173. { The approach is equivalent to TextColor(F); TextBackground(B);}
  174. { except blink is handled directly (any B > 7)}
  175.  
  176. BEGIN
  177.  TextAttr := F + B * 16;
  178. END;
  179.  
  180. {======================================================================}
  181. PROCEDURE WriteSt(St:AnyStr;X,Y:Integer);
  182.  
  183. { Much output is strings.  This routine saves all the GOTOXYs}
  184.  
  185. BEGIN
  186.   GoToXY(X,Y);
  187.   Write(St);
  188. END;
  189.  
  190. {======================================================================}
  191. PROCEDURE WriteCh(Ch:Char;X,Y:Integer);
  192.  
  193. { Service 9, Intr 10 is used because it will write the "unwriteable" }
  194. { low numbered ASCII characters like #07, which produces a beep if   }
  195. { written with a regular Write statement }
  196.  
  197.   BEGIN
  198.       GoToXY(X,Y);             { Put cursor at location }
  199.       R.AH := $09;             { Load A Hi with Service 9 }
  200.       R.BL := TextAttr;        { Load B Lo with Attribute }
  201.       R.BH := 0;               { Load B Hi with Screen 0 }
  202.       R.AL := Ord(Ch);         { Load A Lo with Character to write }
  203.       R.CX := 1;               { Load C with number of times to write (1) }
  204.       Intr($10,R);             { Do Interrupt 10 }
  205.  
  206.   END;
  207.  
  208. {======================================================================}
  209. PROCEDURE WriteManyCh(Ch:Char;X,Y,Num:Integer);
  210.  
  211. { Like WriteCh above except repeats the character Num times. }
  212.  
  213.   BEGIN
  214.       GoToXY(X,Y);
  215.       R.AH := $09;
  216.       R.BL := TextAttr;
  217.       R.BH := 0;
  218.       R.AL := Ord(Ch);
  219.       R.CX := Num;
  220.       Intr($10,R);
  221.  
  222.   END;
  223.  
  224. {======================================================================}
  225. PROCEDURE FillScr(Ch:Char);
  226.  
  227. { Fills the screen with the character passed }
  228.  
  229.   BEGIN
  230.       GoToXY(1,1);
  231.       R.AH := $09;
  232.       R.BL := TextAttr;
  233.       R.BH := 0;
  234.       R.AL := Ord(Ch);
  235.       R.CX := 2000;
  236.       Intr($10,R);
  237.  
  238.   END;
  239.  
  240. {======================================================================}
  241. FUNCTION ReadFromScr(X,Y,Len:Integer):AnyStr;
  242.  
  243. { Uses service 8 of Intr 10 to read a string off the screen }
  244. { The cursor tends to flicker across the screen if this routine }
  245. { is used continuously so the cursor is turned off while it is }
  246. { working by flipping bit 5 of the top scan line to 1 }
  247.  
  248. VAR
  249.    TempStr : AnyStr;
  250.    II,L    : Integer;
  251.    COff    : Boolean;
  252. BEGIN
  253.    COff := False;           { set true if cursor is already off }
  254.                             { turn off the cursor }
  255.    R.AX := $0300;           { Service 3 }
  256.    Intr($10,R);             { Interrupt 10 to get cursor scan lines}
  257.    If (R.CX and $2000) = $2000 then COff := true;
  258.    R.CX := R.CX or $2000;   { Set bit 5 of top scan line to 1 }
  259.    R.AX := $0100;           { Service 1 }
  260.    Intr($10,R);             { Interrupt 10 to turn off }
  261.  
  262.    L := 0;
  263.    For II := 1 to Len Do Begin
  264.      GoToXY(X+II-1,Y);      { Locate cursor }
  265.  
  266.                             { Read a character from the screen }
  267.      R.AX := $0800;         { Service 8 }
  268.      R.BH := 0;             { Screen 0 }
  269.      Intr($10,R);           { Interrupt 10 }
  270.      TempStr[II] := Chr(R.AL);            { Char returned in AL }
  271.      If TempStr[II] <> ' ' then L := II   { if non blank remember length }
  272.    End;
  273.    If not COff then Begin
  274.                               { flip the cursor back on }
  275.      R.AX := $0300;           { Service 3 again }
  276.      Intr($10,R);             { Interrupt 10 to get scan lines }
  277.      R.CX := R.CX and $DFFF;  { Flip bit 5 of top scan line to 0 }
  278.      R.AX := $0100;           { Service 1 }
  279.      Intr($10,R);             {Interrupt 10 to turn on cursor }
  280.    End;
  281.  
  282.    TempStr[0] := Chr(L);    { Set the string length to last non blank char. }
  283.    ReadFromScr := TempStr;  { Set function result to temporary string }
  284.  END;
  285. {======================================================================}
  286. FUNCTION GetCh(X,Y:Integer):Char;
  287.  
  288. { Reads a character from the screen using service 8, Intr 10 }
  289.  
  290. BEGIN
  291.  
  292.    GoToXY(X,Y);            { Locate the cursor }
  293.    R.AX := $0800;          { Service 8 }
  294.    R.BH := 0;              { Screen 0 }
  295.    Intr($10,R);            { Interrupt 10 }
  296.    GetCh := Chr(R.AL);     { Character returned in AL }
  297.  
  298.  END;
  299.  
  300. {======================================================================}
  301. FUNCTION GetAt(X,Y:Integer):Byte;
  302.  
  303. { Reads a color attrubute from the screen using service 8, Intr 10 }
  304.  
  305. BEGIN
  306.  
  307.    GoToXY(X,Y);            { Locate the cursor }
  308.  
  309.    R.AX := $0800;          { Service 8 }
  310.    R.BH := 0;              { Screen 0 }
  311.    Intr($10,R);            { Interrupt 10 }
  312.    GetAt := R.AH;     { Character returned in AL }
  313.  
  314.  END;
  315.  
  316. {======================================================================}
  317. PROCEDURE Border(X1,Y1,X2,Y2: Integer; Header:AnyStr);
  318.  
  319. { Prints a double line box border on the screen with corners at }
  320. { X1,Y1 and X2,Y2.  The Header will be centered on the top.  }
  321.  
  322. VAR Indx : Integer;
  323. BEGIN
  324.    WriteCh('╔',X1,Y1);                      { Upper left corner }
  325.    WriteManyCh('═',X1+1,Y1,X2-X1-1);        { Top }
  326.    WriteCh('╗',X2,Y1);                      { Upper right corner }
  327.    For Indx := Y1+1 to Y2-1 do              { Both sides }
  328.     Begin
  329.      WriteCh('║',X1,Indx);
  330.      WriteCh('║',X2,Indx);
  331.     End;
  332.    WriteCh('╚',X1,Y2);                      { lower left corner }
  333.    WriteManyCh('═',X1+1,Y2,X2-X1-1);        { bottom }
  334.    WriteCh('╝',X2,Y2);                      { lower right corner }
  335.    If Header > '' then                      { Center header }
  336.    WriteSt('╡'+Header+'╞',X1+(X2-X1) div 2-((Length(Header)+1) div 2),Y1);
  337. END;
  338.  
  339. {======================================================================}
  340. PROCEDURE SBorder(X1,Y1,X2,Y2: Integer; Header:AnyStr);
  341.  
  342. { Prints a single line box border on the screen with corners at }
  343. { X1,Y1 and X2,Y2.  The Header will be centered on the top.  }
  344.  
  345. VAR Indx : Integer;
  346. BEGIN
  347.    WriteCh('┌',X1,Y1);                      { Upper left corner }
  348.    WriteManyCh('─',X1+1,Y1,X2-X1-1);        { Top }
  349.    WriteCh('┐',X2,Y1);                      { Upper right corner }
  350.    For Indx := Y1+1 to Y2-1 do              { Both sides }
  351.     Begin
  352.      WriteCh('│',X1,Indx);
  353.      WriteCh('│',X2,Indx);
  354.     End;
  355.    WriteCh('└',X1,Y2);                      { lower left corner }
  356.    WriteManyCh('─',X1+1,Y2,X2-X1-1);        { bottom }
  357.    WriteCh('┘',X2,Y2);                      { lower right corner }
  358.    If Header > '' then                      { Center header }
  359.    WriteSt('┤'+Header+'├',X1+(X2-X1) div 2-((Length(Header)+1) div 2),Y1);
  360. END;
  361.  
  362. {======================================================================}
  363. PROCEDURE Beep;
  364.  BEGIN
  365.  Sound(550); Delay(200); Nosound;
  366.  END;
  367.  
  368. {======================================================================}
  369. PROCEDURE Display(Msg : AnyStr;XD,YD:Integer);
  370. BEGIN
  371.    SAttr := TextAttr;
  372.    SetColor(Green,Black);
  373.    GoToXY(XD,YD); Clreol;
  374.    WriteSt(Msg,XD,YD);
  375.    TextAttr := SAttr;
  376. END;
  377.  
  378. {======================================================================}
  379. PROCEDURE Wait;
  380. VAR
  381.    WCh : Char;
  382. BEGIN;
  383.     Sattr := TextAttr;
  384.     SetColor(Green,Black);
  385.     Display('Hit any key to continue',1,25);
  386.     WCh := Readkey;
  387.     If WCh = #0 then WCh := Readkey;
  388.     TextAttr := Sattr;
  389. END;
  390.  
  391. {======================================================================}
  392. FUNCTION Yes(Prompt:AnyStr):Boolean;
  393. VAR
  394.       InChar : Char;
  395.  BEGIN
  396.       SAttr := TextAttr;
  397.       SetColor(Green,Black);
  398.       GoToXY(1,25);
  399.       ClrEol;
  400.       Display(Prompt,1,25);
  401.       Repeat
  402.         Inchar := Readkey;
  403.         If not (InChar in ['Y','y','N','n']) then Beep;
  404.       until InChar in ['Y','y','N','n'];
  405.       Yes := InChar in ['Y','y'];
  406.       TextAttr := SAttr;
  407.  END;
  408.  
  409. {======================================================================}
  410. PROCEDURE Linecursor;
  411.  
  412. { Sets the cursor to two lines.  Checks type of adapter because }
  413. { Monochrome has more scan lines than CGA/EGA }
  414.  
  415.   Begin
  416.     R.AX := $0100;                   { Service 1 }
  417.     If AdapterType = MDA
  418.              then R.CX := $0C0D      { Mono Adapter }
  419.              else R.CX := $0607;     { Color Adapters }
  420.     Intr($10,R);                     { Interrupt 10 }
  421.   End;
  422.  
  423. {======================================================================}
  424. PROCEDURE Bigcursor;
  425.  
  426. { Sets the cursor to a large block to signify insert.  As above }
  427. { checks adapter }
  428.   Begin
  429.     R.AX := $0100;                    { Service 1 }
  430.     If AdapterType = MDA
  431.              then R.CX := $010D       { Mono Adapter }
  432.              else R.CX := $0107;      { Color Adapter }
  433.     Intr($10,R);                      { Interrupt 10 }
  434.   End;
  435.  
  436. {======================================================================}
  437. PROCEDURE HideCursor;
  438.  
  439. { Turns cursor off by flipping bit 5 of top scan line to 1.    }
  440. { This is a better cursor hiding technique than moving it off  }
  441. { the screen because you can still do GoToXY and the cursor is }
  442. { invisible. }
  443.  
  444.   BEGIN
  445.        R.AX := $0300;               { Service 3 }
  446.        Intr($10,R);                 { Intr 10. Get scan lines}
  447.        R.CX := R.CX or $2000;       { Set bit 5 to 1}
  448.        R.AX := $0100;               { Service 1 }
  449.        Intr($10,R);                 { Intr 10 resets cursor}
  450.   END;
  451.  
  452. {======================================================================}
  453. PROCEDURE ShowCursor;
  454. { Turns cursor on by flipping bit 5 of Top Scan Line back to 0 }
  455.  
  456.   BEGIN
  457.        R.AX := $0300;               { Service 3 }
  458.        Intr($10,R);                 { Intr 10. Get scan lines}
  459.        R.CX := R.CX and $DFFF;      { Set bit 5 to 0}
  460.        R.AX := $0100;               { Service 1 }
  461.        Intr($10,R);                 { Intr 10 resets cursor}
  462.   END;
  463.  
  464. {======================================================================}
  465.  
  466. BEGIN {Initilization}
  467.   CheckAdapter;
  468. END. {OF UNIT}